(library (grid-gen fortran77)

(export f77-code-gen code-gen)

(import (rnrs)
        (rnrs enums (6))
        ;;(chezscheme) 
        (guile)
        (grid-gen main)
        (grid-gen vars)
        (grid-gen code)
        (grid-gen optimizer)
        (grid-gen symath)
        (except (srfi srfi-1) map)
)

(define max-str-len 65)
(define float-type-name (lambda ()
  (cond ((= CODE:precision 4)
         "real*4"
        )
        ((= CODE:precision 8)
         "real*8"
        )
        (#t int-err "Invalid precision")
  )
))
(define int-type-name "integer")
(define cur-indent (list "        "))
(define omp-indent "c$omp   ")
(define join-str "     &    ")
(define omp-join-str "c$omp&    ")

(define last-bnd (list))
(define last-dms (list))
(define fn_list (list))
(define omp-level 0)
(define omp-vars (list))
(define omp-red (list))

(define edp (lambda (sp dp)
  (if (= CODE:precision 4) sp dp)
))


(define indent (lambda ()
  (apply string-append cur-indent)
))

(define-syntax with-indent
  (syntax-rules ()
    ((_ v) (let ((old-ind cur-indent))
             (set! cur-indent (cons "  " cur-indent))
             (let ((r v))
               (set! cur-indent old-ind)
               r
             )
           )
    )
  )
)

(define ptr-stack (list))
(define orig-ptrs (list))

(define var-full-name (lambda (v)
  (let ((vfn
  (string-append (var-name-suffix v)
                 (if (var-has-ind? v)
                   (let* ((i1 (var-ind v))
                          ;(xxx (format #t "P: ~a\n" (car ptr-stack)))
                          ;(xx1 (format #t "D: ~a\n" (var-dims v)))
                          (i2 (if (equal? i1 '(CUR_PTR))
                                  (list-head (car ptr-stack)
                                             (length (var-dims v))
                                  )
                                  (if (equal? i1 '(ORIG_PTR))
                                      (list-head orig-ptrs
                                                 (length (var-dims v))
                                      )
                                      i1
                                  )
                              )
                          )
                         )
                     (if (eq? (length i2) (length (var-dims v)))
                       (print-array-decl i2)
                       (begin
                         (format #t "V: ~a\nI: ~a\n" (var-dims v) i2)
                         (int-err "Index do not match the dimension!")
                       )
                     )
                   )
                   ""
                 )
  )
  ))
;;    (if (equal? vfn "t12") (format #t "~a: ~a\n" vfn (var-id v)))
;;    (if (= (cadr (var-id v)) 2770) (format #t "~a: ~a\n" vfn (var-id v)))
    vfn
  )
))


(define print-array-decl (lambda (dims)
  (letrec ((print-dim (lambda (d)
   (string-append
     (make-expression (car d))
     (if (not (null? (cdr d)))
       (string-append "," (print-dim (cdr d)))
       ""
     )
   ))))
   (if (not (null? dims))
     (string-append
       "("
       (print-dim dims)
       ")"
     )
     ""
   )
  )
))

(define var-dims1 (lambda (v)
  (if (var-has-dims? v)
    (var-dims v)
    (list)
  )
))

(define make-decl (lambda (el)
  (ifvar el
    int:   (list (set-ind (del-ind el) (var-dims1 el)))
    float: (list (set-ind (del-ind el) (var-dims1 el)))
    vect:  (make-decls (reverse (var-elements el)))
  )
))

(define make-decls (lambda (vrs)
  (if (null? vrs)
    (list)
    (append
      (make-decls (cdr vrs))
      (make-decl (car vrs))
    )
  )
))

(define get-type-decls (lambda (typ dls)
  (if (null? dls)
    (list)
    (append (if (eq? (var-type (car dls)) typ)
                (list (var-full-name (car dls)))
                (list)
            )
            (get-type-decls typ (cdr dls))
    )
  )
))




(define make-do (lambda (dims dms bls ptr pre)
;;  (format #t "PTR: ~a\n" ptr)
  (if (null? dms)
    (let ((old-ptr ptr-stack))
      (set! ptr-stack (cons ptr ptr-stack))
      (set! orig-ptrs ptr)
      (let ((src (make-f-source bls)))
        (set! ptr-stack old-ptr)
        (set! orig-ptrs '())
        src
      )
    )
    (let ((v (get-int-var))
          (obnd last-bnd)
         )
      (add-var-onetime v)
      (set! last-bnd (list-ref dims (car dms)))
      (if (> omp-level 0)
          (set! omp-vars (cons v omp-vars))
      )
      (let ((ret (string-append 
                   (if (and pre (= (length dms) 1))
                       (let ((old-ptr ptr-stack)
                             (p1 (cons (simp-ex (car (list-ref dims
                                                               (car dms)
                                                     )
                                                )
                                       )
                                       ptr
                                 )
                             )
                            )
                         (set! ptr-stack (cons p1 ptr-stack))
                         (set! orig-ptrs p1)
                         (let ((src (make-f-source (list pre))))
                           (set! ptr-stack old-ptr)
                           (set! orig-ptrs '())
                           src
                          )
                       )
                       ""
                   )
                   (indent)
                   (format #f "do ~a=~a,~a\n"
                     (var-full-name v)
                     (make-expression (car  (list-ref dims (car dms))))
                     (make-expression (cadr (list-ref dims (car dms))))
                   )
                   (with-indent (make-do dims (cdr dms) bls 
                                         (cons v ptr)
                                         pre
                                )
                   )
                   (indent) "end do\n"
                 )))
        (free-vars (list v))
        (set! last-bnd obnd)
        ret
      )
    )
  )
))

(define make-loop (lambda (dims dms bls pre)
  (let ((odms last-dms))
    (set! last-dms dms)
    (let ((res (make-do dims
                        (reverse dms)
                        bls 
                        (if (null? ptr-stack)
                            (list)
                            (car ptr-stack)
                        )
                        pre
               )
          )
         )
      (set! last-dms odms)
      res
    )
  )
))

(define mk-ind-in (lambda (vals)
  (letrec* ((i (car vals))
            (d (cadr vals))
            (o (caddr vals))
            (iir (lambda (i1 r1)
              (string-append
                (format #f "(~a).gt.~a.and.(~a).lt.(1+~a-~a)"
                        (make-expression (car i1)) (make-expression o)
                        (make-expression (car i1)) (make-expression (car r1))
                                                   (make-expression o)
                )
                (if (not (null? (cdr r1)))
                    (string-append ".and." (iir (cdr i1) (cdr r1)))
                    ""
                )
              )
            ))
           )
    (iir i d)
  )
))


(define expand-op-fn (lambda (ex)
  (letrec* ((op (car ex))
            (vals (cdr ex))
            (glue-list (lambda (l s)
              (string-join (map make-expression l) s)
            ;  (if (null? (cdr l))
            ;    (make-expression (car l))
            ;    (string-append (make-expression (car l)) 
            ;                   s
            ;                   (glue-list (cdr l) s)
            ;    )
            ;  )
            ))
            (mk-fn (lambda (fn pars)
              (string-append fn "(" (glue-list pars ",") ")")
            ))
           )
    (cond ((eq? op '+)
           ;(if (and (= (length vals) 2)
           ;         (list? (cadr vals))
           ;         (= (length (cadr vals)) 3)
           ;         (eq? (car (cadr vals)) '*)
           ;    )
           ;    (cond ((and (number? (cadr (cadr vals)))
           ;                (= (cadr (caddr vals)) -1)
           ;           )
           ;           (expand-op-fn `(- ,(car vals) ,(caddr (cadr vals))))
           ;          )
           ;          ((and (number? (caddr (cadr vals)))
           ;                (= (caddr (cadr vals)) -1)
           ;           )
           ;           (expand-op-fn `(- ,(car vals) ,(cadr (cadr vals))))
           ;          )
           ;          (#t (glue-list vals "+"))
           ;    )
               (glue-list vals "+")
           ;)
          )
          ((eq? op '-)  (glue-list vals "-"))
          ((eq? op '*)  (glue-list vals "*"))
          ((eq? op '/)  (glue-list vals "/"))
          ((eq? op '**) 
            ;(if (and (number? (car vals)) (number? (cadr vals)))
            ;    (make-expression (expt (car vals) (cadr vals)))
                (string-append (make-expression (car vals))
                                "**"
                               (make-expression (cadr vals))
                )
            ;)
          )
          ((eq? op '=) (string-append (make-expression (car vals))
                                          ".eq."
                                          (make-expression (cadr vals))
                           )
          )
          ((eq? op '>) (string-append (make-expression (car vals))
                                          ".gt."
                                          (make-expression (cadr vals))
                           )
          )
          ((eq? op '>=) (string-append (make-expression (car vals))
                                          ".ge."
                                          (make-expression (cadr vals))
                           )
          )
          ((eq? op '<) (string-append (make-expression (car vals))
                                          ".lt."
                                          (make-expression (cadr vals))
                           )
          )
          ((eq? op '<=) (string-append (make-expression (car vals))
                                          ".le."
                                          (make-expression (cadr vals))
                           )
          )
          ((eq? op 'sin)  (mk-fn (edp "sin"  "dsin")  vals))
          ((eq? op 'asin) (mk-fn (edp "asin" "dasin") vals))
          ((eq? op 'cos)  (mk-fn (edp "cos"  "dcos")  vals))
          ((eq? op 'acos) (mk-fn (edp "acos" "dacos") vals))
          ((eq? op 'tan)  (mk-fn (edp "tan"  "dtan")  vals))
          ((eq? op 'atan) (mk-fn (edp "atan" "datan") vals))
          ((eq? op 'log)  (mk-fn (edp "log"  "dlog")  vals))
          ((eq? op 'exp)  (mk-fn (edp "exp"  "dexp")  vals))
          ((eq? op 'sqrt) (mk-fn (edp "sqrt" "dsqrt") vals))
          ((eq? op 'int) (mk-fn "int" vals))
          ((eq? op 'real) (mk-fn "real" vals))
          ((eq? op 'floor) (mk-fn "floor" vals))
          ((eq? op 'ceil) (mk-fn "ceil" vals))
          ((eq? op 'sign) (mk-fn (edp "sign" "dsign") (list 1.0 (car vals))))
          ((eq? op 'epsilon) (mk-fn "epsilon" `(1.0)))
          ((eq? op 'abs)  (mk-fn (edp "abs"  "dabs")  vals))
          ((eq? op 'min)  
           (if (= (length vals) 1)
               (make-expression (car vals))
               (mk-fn "min" vals)
           )
          )
          ((eq? op 'max)  
           (if (= (length vals) 1)
               (make-expression (car vals))
               (mk-fn "max" vals)
           )
          )
          ((eq? op 'and)  (glue-list vals ".and."))
          ((eq? op 'or)   (glue-list vals ".or."))
          ((eq? op 'not)  (mk-fn ".not." vals))
          ((eq? op 'IND_IN)  (mk-ind-in vals))
          ((eq? op 'PTR_IN)  (mk-ind-in (cons (car ptr-stack) vals)))
          ((eq? op 'isnan) (mk-fn "isnan" vals))
          ((eq? op 'omp_get_wtime) (mk-fn "omp_get_wtime" vals))
          ((eq? op 'time) (make-expression code:global-timer))
          (#t (int-err "Invalid operator or function"))
    )
  )
))

(define mk-num (lambda (n)
  (let* ((s (number->string n))
         (ss (edp s
                  (string-map (lambda (x) (if (char-ci=? x #\e) #\d x)) s)
             )
         )
        )
    (if (and (not (string-has? (edp #\e #\d) ss)) (string-has? #\. ss))
        (string-append ss (edp "e0" "d0"))
        ss
    )
  )
))

(define make-expression (lambda (ex1)
;;  (format #t "ME: ~a\n" ex1)
  (let ((ex (if (string? ex1) ex1 (simp-ex (exp-v-def (exp-ptrs ex1) #f)))))
    (cond ((number? ex)
           (if (< ex 0)
               (format #f "(~a)" (mk-num ex))
               (mk-num ex)
           )
          )
          ((string? ex) (string-append "'" ex "'"))
          ((symbol? ex) (symbol->string ex))
          ((is-op? ex) (string-append "(" (expand-op-fn ex) ")"))
          ((is-fn? ex) (expand-op-fn ex))
          ((boolean? ex) (if ex ".true." ".false."))
          ((is-var? ex)
           ;(if (ex 'def-expand?)
           ;    (make-expression (var-def ex))
               (var-full-name (add-var-onetime ex))
           ;)
          )
          (#t (int-err "Invalid expression: ~a" ex))
    )
  )
))

(define exp-ptrs (lambda (ex1)
  (let ((ex (simp-ex ex1)))
    (cond ((or (is-op? ex) (is-fn? ex)) 
           (cons (car ex)
                 (map exp-ptrs (cdr ex))
           )
          )
          ((is-orig-ptr? ex)
           (list-ref orig-ptrs (cadr ex))
          )
          ((is-ptr? ex)
           (list-ref (car ptr-stack) (cadr ex))
          )
          (#t ex)
    )
  )
))

(define make-set-var (lambda (v e)
  (string-append
;;    (format #f "c ~a\n" (var-id v))
    (indent) (var-full-name (add-var-onetime v)) "=" 
             (make-expression e) "\n"
  )
))

(define make-set-vals (lambda (l e)
  (if (null? l)
    ""
    (string-append
      (make-set-val (car l) e)
      (make-set-vals (cdr l) e)
    )
  )
))

(define make-set-val (lambda (v e)
  (if (var-has-elements? v)
    (make-set-vals (var-elements v) e)
    (make-set-var v e)
  )
))

(define make-every (lambda (dt un cod)
  (let* ((unm (cond ((eq? un 'sec) 1)
                    ((eq? un 'min) 60)
                    ((eq? un 'hour) (* 60 60))
              )
         )
         (dte `(* ,dt ,unm))
         (otv (comp-float "tstamp"))
         (ftv (comp-float "tstamp_flg" 0))
         (ctv (comp-float "cur_time"))
        )
    (make-f-source
      `((if (= ,ftv 0)
           ,(beg
              (set-val otv code:zero-tim)
              (set-val ftv 1)
            )
            ()
        )
        (if (>= ,code:global-timer (+ ,otv ,dte))
            ,(cons
               'CODE_BEGIN
                (cons `(SET_VAL ,otv (+ ,otv ,dte))
                       cod
                )
             )
             ()
         )
       )
    )
  )
))

(define make-measure-time (lambda (vr cod)
  (let* ((ms1 (comp-int "ms"))
         (ms2 (comp-int "ms"))
         (mr  (comp-int "mr"))
         (mm  (comp-int "mm"))
         (dm  (comp-float "dm"))
         (rt  (comp-float "rt"))
         (dmm (comp-float "dmm"))
        )
    (make-f-source
      (list
        (call "SYSTEM_CLOCK" ms1)
        (apply beg cod)
        (call "SYSTEM_CLOCK" ms2 mr mm)
        (set-val dm `(- ,ms2 ,ms1))
        (set-val rt mr)
        (set-val dmm mm)
       `(if (< ,ms1 ,ms2)
           ,(set-val vr `(/ ,dm ,rt))
           ,(set-val vr `(/ (+ ,dmm ,dm) ,rt))
        )
      )
    )
  )
))

(define make-if (lambda (cnd tr fa)
;;  (format #t "MKIF: ~a ~a ~a\n" cnd tr fa)
  (let* (
;;     (x1 (format #t "CND: ~a\n" (make-expression cnd)))
;;     (x2 (format #t "TR: ~a\n" (make-f-source (list tr))))
;;     (x3 (format #t "FA: ~a\n" (make-f-source (list fa))))
    (res 
  (string-append (indent) "if (" (make-expression cnd) ") then\n"
                 (with-indent (make-f-source (list tr)))
                 (if (null? fa)
                   ""
                   (string-append (indent) "else\n"
                                  (with-indent (make-f-source (list fa)))
                   )
                 )
                 (indent) "end if\n"
  ))
;;   (x4 (format #t "RRRR!\n"))
  )
;;   (format #t "IFR: ~a\n" res)
   res
  )
))

(define simple-ex? (lambda (ex)
  (or (number? ex)
      (string? ex)
      (is-var? ex)
      (and (list? ex)
           (not (null? ex))
           (letrec ((op (car ex))
                    (args (cdr ex))
                    (simple-l (lambda (l)
                      (if (null? l)
                        #t
                        (and (simple-ex? (car l)) (simple-l (cdr l)))
                      )
                    ))
                   )
             (and (not (eq? op 'if))
                  (simple-l args)
             )
           )
      )
  )
))

(define expand-set-val-cond (lambda (ex)
  ;;(format #t "ESVC: ~a\n" ex)
  (letrec* ((e-v-c-l (lambda (l)
             ;;(format #t "EVCL: ~a\n" l)
             (if (null? l)
               (list (list) (list) (list))
               (let ((r1 (e-v-c (car l)))
                     (r2 (e-v-c-l (cdr l)))
                    )
                 (list (append (car r1) (car r2))
                       (cons (caadr r1) (cadr r2))
                       (append (caddr r1) (caddr r2))
                 )
               )
             )
           ))
           (e-v-c (lambda (e)
             ;;;(format #t "EVC: ~a\n" e)
             (if (and (list? e) (eq? (car e) 'SET_VAL))
                 (format #t "SV: ~a = ~a\n" ((cadr e) 'name) (caddr e))
             )
             (cond ((number? e) (list (list) (list e) (list)))
                   ((string? e) (list (list) (list e) (list)))
                   ((symbol? e) (list (list) (list e) (list)))
                   ((is-var? e) (list (list) (list e) (list)))
                   ((list? e)
                     (if (null? e) 
                         (list (list) e (list))
                         (let ((res (e-v-c-l (cdr e))))
                           (if (eq? (car e) 'if)
                             (let* ((tv (cond ((is-int? (cadr ex))
                                               (get-int-var)
                                              )
                                              ((is-float? (cadr ex))
                                               (get-float-var)
                                              )
                                              (#t (int-err "VT!"))
                                        )
                                    )
                                   )
                               (if (> omp-level 0)
                                   (set! omp-vars (cons tv omp-vars))
                               )
                               (add-var-onetime tv)
                               (list (append (car res)
                                             (list
                                               (list 'if 
                                                     (car (cadr res))
                                                     (set-val
                                                       tv
                                                       (cadr  (cadr res))
                                                     )
                                                     (set-val
                                                       tv
                                                       (caddr (cadr res))
                                                     )
                                               )
                                            )
                                     )
                                     (list tv)
                                     (cons tv (caddr res))
                               )
                             )
                             (list (car res) 
                                   (list (cons (car e) (cadr res)))
                                   (caddr res)
                             )
                           )
                         )
                     )
                   )
                   (#t (int-err (format #f "Invalid term: ~a" e)))
             )
           ))
           (rres (e-v-c ex))
          )
    (free-vars (caddr rres))
    (append (car rres) (cadr rres))
  )
))

(define m-equal? (lambda l
  (if (< (length l) 2)
      #t
      (and (equal? (car l) (cadr l))
           (m-equal? (cdr l))
      )
  )
))

(define make-to-file (lambda (fname flgs wrp cod)
  (let ((fn (+ (apply max (cons 0 fn_list)) 1))
        (fl-old fn_list)
       )
    (set! fn_list (cons fn fn_list))
    (let ((cd1 (string-append
             (indent) "open(" (number->string fn) ", file='" fname "'"
               (apply string-append
                 (map (lambda (flg)
                        (cond ((eq? flg 'bin)
                               " ,form='unformatted', access='stream'"
                              )
                              ((eq? flg 'append)
                               " ,status='old'"
                              )
                              ((eq? flg 'replace)
                               " ,status='replace'"
                              )
                              ((eq? flg 'main) "")
                              (#t (int-err "Invalid flag for to-file"))
                        )
                      )
                      flgs
                 )
               )
               ")\n"
      (if (member 'append flgs)
          (string-append (indent) "call fseek(" (number->string fn) ",0,2)\n")
          ""
      )
               ))
          (cd2 (with-indent (make-f-source cod)))
          (cd3 (string-append (indent) "close(" (number->string fn) ")\n"))
         )
      (set! fn_list fl-old)
      (if wrp
          (string-append
             (indent) "if (" (make-expression wrp) ") then\n"
                      "  " cd1
             (indent) "end if\n"
                      cd2
             (indent) "if (" (make-expression wrp) ") then\n"
                      "  " cd3
             (indent) "end if\n"
          )
          (string-append cd1 cd2 cd3)
      )
    )
  )
))

(define make-fprint (lambda (vrs)
  (format #t "FPRINT: ~a\n" vrs)
  (string-append
    (indent)
    (format #f "write(~a,*)" (car fn_list))
    (string-join (map make-expression vrs) ",")
    "\n"
  )
))

(define make-fwrite (lambda (vrs)
  (string-append
    (indent)
    (format #f "write(~a)" (car fn_list))
    (string-join (map make-expression vrs) ",")
    "\n"
  )
))

(define make-print (lambda (bls)
  (string-append (indent) "write(*,*)"
    (string-join (map make-expression bls) ",")
    "\n"
  )
))

(define make-while (lambda (ex exs)
  (string-append
    (indent) "do while(" (make-expression ex) ")\n"
    (with-indent (make-f-source exs))
    (indent) "end do\n"
  )
))

(define make-call (lambda (fn args)
  (string-append
    (indent) "call " fn "(" (string-join (map make-expression args) ",") ")\n"
  )
))

(define make-f-source (lambda (blocks)
  (let ((ebl blocks))
;;     (format #t "MFC: ~a\n" ebl)
    (string-append
      (if (and (list? ebl) (not (null? ebl)))
        (string-append
          (let ((bl (car ebl)))
            (cond
              ((unspecified? bl) "")
              ((eq? (car bl) 'CODE_LOOP)
               (make-loop (cadr (obj-find-el bl 'LOOP_DIMS))
                          (cadr (obj-find-el bl 'LOOP_SEQ))
                          (cdr  (obj-find-el bl 'LOOP_CODE))
                          (let ((pc (obj-find-el bl 'LOOP_PRE_CODE)))
                            (if pc (cadr pc) #f)
                          )
               )
              )
              ((eq? (car bl) 'CODE_WHILE)
                (make-while (list-ref bl 1) (list-ref bl 2))
              )
              ((eq? (car bl) 'CODE_TO_FILE)
               (apply make-to-file (list-tail bl 1))
              )
              ((eq? (car bl) 'CODE_BEGIN)
                (make-f-source (cdr bl))
              )
              ((eq? (car bl) 'CODE_MAINP)
                (make-f-source (cdr bl))
              )
              ((eq? (car bl) 'RUN_CODE)
                (make-f-source (cdr bl))
              )
              ((eq? (car bl) 'OMP_REDUCE)
               (set! omp-red (cons `(,(cadr (cadr bl)) ,(caddr bl)) omp-red))
                   ;;; detect OMP_FUNC !!!!!!!!
               ""
              )
              ((eq? (car bl) 'OMP_LOCALS)
               (set! omp-vars (append (cdr bl) omp-vars))
               ""
              )
              ((eq? (car bl) 'OMP_DO)
               (let ((ompl omp-level))
                 (set! omp-level (+ 1 omp-level))
                 (let ((rc (make-f-source (cdr bl))))
                   (set! omp-level ompl)
                   (if (and (= omp-level 0)
                            CODE:enable-SMP
                            (or (not OpenMP:nproc)
                                (> OpenMP:nproc 1)
                            )
                       )
                       (string-append
                         omp-indent "parallel do private("
                         (let* ((tov (let ((h (make-hash-table)))
                                       (for-each 
                                         (lambda (x)
                                           (if (hash-ref (var-pool)
                                                         (var-id x)
                                                         #f
                                               )
                                               (hash-set! h (var-id x) x)
                                           )
                                         )
                                         omp-vars
                                       )
                                       (hash-map->list (lambda (k v) v) h)
                                     )
                                )
                               )
                           (set! omp-vars (list))
                           (string-join (map var-name-suffix tov) ",")
                         )
                         ") default(shared)"
                         (let ((trv omp-red)
                               (vrht (make-hash-table))
                              )
                           (set! omp-red (list))
                           (if (not (null? trv))
                               (string-join
                                 (map
                                   (lambda (x)
                                     (if (hash-ref vrht (var-id (cadr x)) #f)
                                         ""
                                         (begin
                                           (hash-set! vrht 
                                                      (var-id (cadr x))
                                                      #t
                                           )
                                           (string-append
                                             " reduction("
                                             (cond ((eq? (car x) 'min)
                                                    "min"
                                                   )
                                                   ((eq? (car x) 'max)
                                                    "max"
                                                   )
                                                   (#t (begin
                                             (format #t "OMPR: ~a\n" (car x))
                                                       (int-err
                                                "Invalid omp-reduce operator"
                                                       )
                                                       )
                                                   )
                                             )
                                             ":"
                                             (var-name-suffix (cadr x))
                                             ")"
                                           )
                                         )
                                     )
                                   )
                                   trv
                                 )
                                 " "
                               )
                               ""
                           )
                         )
                         " schedule(dynamic)"
                         "\n"
                         rc
                         omp-indent "end parallel do\n"
                       )
                       rc
                   )
                 )
               )
              )
              ((eq? (car bl) 'RAW)
                (string-append (indent) (cadr bl) "\n")
              )
              ;((eq? (car bl) 'LOOP_PRE_CODE)
              ; (make-f-source
              ;   `((if (= (CUR_PTR ,(cadr bl)) ,(caddr bl))
              ;        ,(cadddr bl)
              ;         ()
              ;     )
              ;    )
              ; )
              ;)
              ((eq? (car bl) 'CODE_FWRITE)
                (make-fwrite (cdr bl))
              )
              ((eq? (car bl) 'CODE_FPRINT)
                (make-fprint (cdr bl))
              )
              ((eq? (car bl) 'CODE_PRINT)
                (make-print (cdr bl))
              )
              ((eq? (car bl) 'CODE_EVERY)
                (make-every (cadr bl) (caddr bl) (cadddr bl))
              )
              ((eq? (car bl) 'CODE_MEASURE_TIME)
                (make-measure-time (cadr bl) (caddr bl))
              )
              ((eq? (car bl) 'CODE_CALL)
                (make-call (cadr bl) (caddr bl))
              )
              ((eq? (car bl) 'SET_VAL)
                (if (simple-ex? (list-ref bl 2))
                  (make-set-val (list-ref bl 1) (list-ref bl 2))
                  (make-f-source (expand-set-val-cond bl))
                )
              )
              ((eq? (car bl) 'SET_PTR)
               (set-car! ptr-stack (map exp-ptrs (cadr bl)))
               ;;;(format #f "ccc ~a\n" bl)
               ""
              )
              ((eq? (car bl) 'if)
                (make-if (list-ref bl 1) (list-ref bl 2) (list-ref bl 3))
              )
              (#t "")
            )
          )
          (make-f-source (cdr ebl))
        )
        ""
      )
    )
  )
))

(define glue-decl (lambda (pref dls max-len)
  (letrec ((j-a-max (lambda (dls m cur)
                      (if (null? dls)
                        cur
                        (let ((sl (+ 1 (string-length (car dls)))))
                          (if (or (null? (car cur)) (<= sl m))
                            (j-a-max (cdr dls)
                                     (- m sl)
                                     (cons (append (car cur)
                                                   (list (car dls))
                                           )
                                           (cdr cur)
                                     )
                            )
                            (j-a-max dls
                                     max-len
                                     (cons (list) cur)
                            )
                          )
                        )
                      )
                    )
           )
           (gl-l (lambda (l)
                   (if (null? l)
                     ""
                     (string-append (car l)
                                    (if (null? (cdr l))
                                      ""
                                      (string-append "," (gl-l (cdr l)))
                                    )
                     )
                   )
                 )
           )
           (al-l (lambda (l)
                   (if (null? l)
                     ""
                     (string-append (if (null? (cdr l))
                                      ""
                                      (al-l (cdr l))
                                    )
                                    (indent)
                                    pref
                                    " "
                                    (gl-l (car l))
                                    "\n"
                     )
                   )
                 )
           )
          )
    (let ((res (al-l (j-a-max dls max-len (list (list))))))
        ;; (format #t "RES: ~a\n" res)
         res
    )
  )
))

(define init-vars2 (lambda (vrs)
  (if (null? vrs)
    (list)
    (let ((v (car vrs)))
      (if (var-has-def? v)
          (cons (set-val v (var-def v)) (init-vars (cdr vrs)))
          (init-vars (cdr vrs))
      )
    )
  )
))

(define init-vars (lambda (vrs)
  (init-vars2 (map cadr
                   (sort (map (lambda (v) `(,(v 'ord) ,v)) vrs)
                         (lambda (v1 v2) (< (car v1) (car v2)))
                   )
              )
  )
))

(define f-sb (lambda (s)
  (let* ((l1 (string-index s #\'))
         (l2 (if l1
                 (string-index (substring s (+ l1 1) (string-length s)) #\')
                 #f
             )
         )
        )
    (if (and l1 l2)
       `(,l1 ,(+ l2 l1 2))
        #f
    )
  )
))

(define f-ml (lambda (s ml)
  (let* ((sb (f-sb s))
         (sl (string-length s))
         (l (string-index s (string->char-set ",+-*/=) ")))
         (l1 (if (not sb)
                l
                (if (or (not l) (and (>= l (car sb)) (<= l (cadr sb))))
                    (cadr sb)
                    l
                )
            )
         )
        )
    (if (or (not l1) (>= l1 ml))
        0
        (+ l1 1 (f-ml (substring s (+ l1 1) sl) (- ml (+ l1 1))))
    )
  )
))

(define ssub-str (lambda (s ml)
  (let* ((ml0 (f-ml s ml))
         (ml1 (if (= ml0 0) ml ml0))
        )
    `(,(substring s 0 ml1) ,(substring s ml1 (string-length s)))
  )
))

(define norm-line (lambda (s)
  (let ((sl (string-length s)))
    (if (<= sl max-str-len)
      (string-append s "\n")
      (let* ((lsrs (ssub-str s max-str-len))
             (ls (car lsrs))
             (rs (cadr lsrs))
            )
        (if (string-contains-only? #\space ls)
          (norm-line rs)
          (string-append
            ls "\n" 
            (norm-line 
              (string-append
                (if (and (> sl 5) 
                         (string-ci=? (string-take s 5) "c$omp")
                    )
                    omp-join-str
                    join-str
                )
                rs
              )
            )
          )
        )
      )
    )
  )
))

(define norm-txt (lambda (s)
  (letrec ((n-s-l (lambda (l)
                    (if (null? l)
                      ""
                      (string-append
                        (norm-line (car l))
                        (n-s-l (cdr l))
                      )
                    )
                  )
          ))
    (n-s-l (string-split s #\newline))
  )
))

(define f77-code-gen (lambda (name blocks)
;;  (format #t "BL: ~a\n" blocks)
  (norm-txt
    (string-append
      (indent) "program " name "\n\n"
      (apply string-append
        (map (lambda (s) (string-append (indent) "include '" s "'\n")) includes)
      )
      (if (null? includes) "" "\n")
      (let ((cod (make-f-source (list (code:pass-all blocks)))))
;;        (format #t "COD: ~a\n" cod)
        (map (pip make-expression var-def)
             (filter var-has-def? (hash-map->list (lambda (k v) v) (var-pool)))
        )
        (string-append 
          (let* ((dls (make-decls (hash-map->list (lambda (k v) v) (var-pool))))
                 (idls (get-type-decls 'INT dls))
                 (fdls (get-type-decls 'FLOAT dls))
                )
;;            (format #t "DLS: ~a\n" dls)
            (string-append
              (if (not (null? fdls))
                (glue-decl (float-type-name) fdls
                           (- max-str-len
                              (string-length (indent))
                              (string-length (float-type-name))
                           )
                )
                ""
              )
              (if (not (null? idls))
                (glue-decl int-type-name idls
                           (- max-str-len
                              (string-length (indent))
                              (string-length int-type-name)
                           )
                )
                ""
              )
            )
          )
    ;;;;      (indent) "character*256 strbuf\n"
          "\n"
          (make-f-source
            (init-vars (hash-map->list (lambda (k v) v) (var-pool)))
          )
          "\n"
          cod
        )
      )
      "\n" (indent) "end\n"
    )
  )
))

(define-syntax code-gen
  (syntax-rules ()
    ((_ name b1 ...)
     (letrec* ((f (transcoded-port
                    (open-file-output-port
                      (string-append name ".f")
                      (file-options no-fail)
                    )
                    (native-transcoder)
                  )
               )
               (cod (f77-code-gen name (quasiquote (b1 ...))))
              )
       (format f "~a" cod)
       (close-port f)
     )
    )
  )
)

)
